home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pcpm.arc / CPAHOLY.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1985-06-04  |  3.1 KB  |  131 lines
  1. 10  REM **** CPAHOLY ****
  2. 12  DEFINT A-Z:DEFSNG H
  3. 15  DIM H(1000),D$(12)
  4. 18  CLOSE
  5. 20  PRINT "**** THIS MODULE CREATES AND MANAGES HOLIDAY [.HOL] FILES ****"
  6. 21  D$(2)="February"
  7. 22  D$(3)="March"
  8. 23  D$(4)="April"
  9. 24  D$(5)="May"
  10. 25  D$(6)="June"
  11. 26  D$(7)="July"
  12. 27  D$(8)="August"
  13. 28  D$(9)="September"
  14. 29  D$(10)="October"
  15. 30  PRINT
  16. 31  D$(1)="January"
  17. 32  D$(11)="November"
  18. 33  D$(12)="December"
  19. 40  RSVRD$=".BAS":EXTN$=".HOL"
  20. 50  INPUT "Enter the name of the base data file ";F9$
  21. 55  GOSUB 12000
  22. 60  F$=F9$:GOSUB 10250:IF F9=1 THEN 50
  23. 140  GOSUB 8000   'READ HOLIDAY FILE
  24. 150  IF N=0 THEN 500
  25. 310  PRINT "**** LIST OF HOLIDAYS FOR THE BASE DATA FILE ";G$;"****":PRINT
  26. 311  FOR I=1 TO N
  27. 312  D8=H(I)
  28. 314  GOSUB 4500
  29. 315  PRINT I;D$(M5);D5;"19";RIGHT$(STR$(Y5),2)
  30. 316  IF I MOD 20=0 THEN INPUT "Press ENTER to Continue ",Q$
  31. 317  NEXT I
  32. 318  PRINT
  33. 320  INPUT "Do you want to change, add, delete or quit (C/A/D/Q) ";Q$
  34. 330  IF Q$="Q" THEN 440
  35. 335  IF Q$="D" THEN 2000
  36. 340  IF Q$="A" THEN 500
  37. 345  IF Q$<>"C" THEN BEEP:GOTO 320
  38. 350  INPUT "Enter number of holiday to change ";K
  39. 360  IF K>N THEN 350
  40. 400  INPUT "Enter new date in MM,DD,YY format ";M6,D6,Y6
  41. 410  GOSUB 5000
  42. 420  H(K)=D8
  43. 430  GOTO 310
  44. 440  GOSUB 3000
  45. 450  CHAIN "CPAMENU"
  46. 500  INPUT "Enter holiday in MM,DD,YY format (0,0,0 if end) ";M6,D6,Y6
  47. 505  IF M6=0 THEN 310
  48. 510  GOSUB 5000
  49. 512  N=N+1
  50. 514  H(N)=D8
  51. 516  GOTO 500
  52. 1000  I=0
  53. 1010  PRINT "**** ENTER HOLIDAYS IN MM,DD,YY FORMAT - ENTER 0,0,0 IF AT END ****"
  54. 1020  I=I+1
  55. 1030  PRINT "Enter holiday";I;
  56. 1040  INPUT M6,D6,Y6
  57. 1050  IF M6=0 THEN 1090
  58. 1060  GOSUB 5000
  59. 1070  H(I)=D8
  60. 1080  GOTO 1020
  61. 1090  N=I-1
  62. 1100  GOTO 310
  63. 2000  'DELETE
  64. 2010  INPUT "Enter number of holiday to delete ";K
  65. 2020  IF K=0 THEN 310
  66. 2030  IF K>N THEN BEEP:PRINT "**** INVALID RESPONSE - MAXIMUM IS";N;"****":GOTO 2010
  67. 2040  FOR J=K TO N-1
  68. 2050  H(J)=H(J+1)
  69. 2060  NEXT
  70. 2070  N=N-1:GOTO 310
  71. 3000  REM WRITE ARRAY TO FILE
  72. 3002  INPUT "File changes or Quit (F/Q) ";Q$
  73. 3003  IF LEFT$(Q$,1)="Q" THEN RETURN
  74. 3004  PRINT "**** FILENAME IS ";F9$;" ****"
  75. 3009  OPEN F9$ FOR OUTPUT AS #1
  76. 3020  FOR I=1 TO N
  77. 3030  WRITE #1,H(I)
  78. 3040  NEXT I
  79. 3045  CLOSE #1
  80. 3050  RETURN
  81. 4490  REM ** CONVERT CENTURY DAY TO MM, DD, YY **************************
  82. 4500  T9=INT(D8/1461)
  83. 4510  Y5=INT((D8-T9+364)/365)
  84. 4520  Y4=D8-INT((Y5-1)*1461/4)
  85. 4530  L8=2
  86. 4540  IF Y5/4=INT(Y5/4) THEN L8=1
  87. 4550  T9=Y4
  88. 4560  IF T9>61-L8 THEN T9=T9+L8
  89. 4570  M5=INT((T9*9+269)/275)
  90. 4580  D5=T9-INT(M5*275/9)+30
  91. 4590  D4=D8-INT(D8/7)*7+1
  92. 4600  RETURN
  93. 4999  REM ** GET DAY OF CENTURY OF STARTING DATE **
  94. 5000  L8=2
  95. 5010  IF INT(Y6/4)=Y6/4 THEN L8=1
  96. 5020  D7=INT(M6*275/9)+D6-30
  97. 5030  IF M6>2 THEN D7=D7-L8
  98. 5040  D8=INT((Y6-1)*1461/4)+D7
  99. 5050  RETURN
  100. 8000  ON ERROR GOTO 8200
  101. 8010  OPEN F9$ FOR INPUT AS #1
  102. 8020  J=0
  103. 8030  J=J+1
  104. 8040  IF EOF(1) THEN 8100
  105. 8050  INPUT #1,H(J)
  106. 8060  GOTO 8030
  107. 8100  N=J-1  'NUMBER OF HOLIDAYS
  108. 8110  CLOSE #1:RETURN
  109. 8200  IF ERR=53 THEN PRINT "**** NEW FILE ****":RESUME 8110
  110. 8210  GOTO 11000
  111. 10000  PRINT "**** NEW FILE ****":CLOSE #1:GOTO 1000
  112. 10250  REM SUBROUTINE TO CHECK FILENAMES - PASS IN F9$
  113. 10254  F9=0
  114. 10256  L9=LEN(F9$):IF L9>12 OR L9<1 THEN BEEP:GOTO 10274
  115. 10258  I9=INSTR(F9$,".")
  116. 10260  IF I9<>0 THEN 10266
  117. 10262  IF L9<9 THEN F9$=F9$+EXTN$ ELSE F9$=LEFT$(F9$,8)+EXTN$
  118. 10264  GOTO 10280
  119. 10266  IF RIGHT$(F9$,4)=EXTN$ THEN 10280
  120. 10268  PRINT "**** WRONG EXTENSION - PLEASE DIAL AGAIN ****":BEEP:GOTO 10278
  121. 10270  IF RIGHT$(F9$,4)=RSRVD$ THEN 10272 ELSE 10280
  122. 10272  PRINT "**** RESERVED EXTENSION - REENTER ****":BEEP
  123. 10274  IF L9<1 THEN PRINT "**** FILENAME TOO SHORT ****"
  124. 10276  IF L9>12 THEN PRINT "**** FILENAME TOO LONG ****"
  125. 10278  F9=1 'BAD FILENAME - REENTER
  126. 10280  RETURN
  127. 11000  PRINT "ERROR NUMBER";ERR;"AT LINE";ERL;"PLEASE NOTE":END
  128. 12000  I1=INSTR(G$,".")
  129. 12005  IF I1<>0 THEN G$=LEFT$(G$,I1-1)
  130. 12010  RETURN
  131.